home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / TPRINT.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  14KB  |  399 lines
  1. Program TPrint;
  2.  
  3. {$M 20000,0,100000 }
  4.  
  5. uses PbMISC, PbDATA, PbOBJS, PbHIGH, PbPARMS, PbTBOX, PbOUT1;
  6.  
  7. {
  8. Description : Not so Minimalist Text file processing program
  9.  
  10. Author      : Howard Richoux
  11. Date        : 1/1/91
  12. Last revised: 1/5/94  3.00 Brought up to current standards
  13.               1/5/94  3.01 \SOURCE section
  14.               1/7/93  3.02 center/join problem
  15.               1/7/94  3.03 add @1-@9 substitution parameters
  16.               2/18/94 3.05 NEW LIBRARIES
  17. Application : IBM PC and compatibles, done in Turbo Pascal 7.0
  18. Status      : Placed in the Public Domain by HNR Software 1/29/94
  19. Published in: none
  20. }
  21.  
  22.  
  23.  
  24.  
  25. var TriggerCh      : char;        { '\'                   }
  26.     center         : integer;     {number of lines to center }
  27.     secttag        : string[30];  {\SECTION ... for sourcing }
  28.  
  29.     EchoFlag       : boolean;     {echo tprint commands (debugging)}
  30.     SourceFlag     : boolean;     {read secondlevel files or not }
  31.     DoubleFlag     : boolean;     {double space lines        }
  32.     HeadersFlag    : boolean;     {turn off headers          }
  33.     FootersFlag    : boolean;     {turn off footers          }
  34.     SectLineFlag   : boolean;     {true when first line of sourced section}
  35.  
  36. var AtStr : array[1..9] of string;
  37.  
  38.  
  39. Procedure CheckPageLimits(pFirst,pLast,pCount : integer);
  40.      begin
  41.      OUTSetPrint;
  42.      if OUTCurrentpage < pfirst then OUTSetNOPrint;
  43.      if OUTCurrentpage > pLast  then OUTSetNOPrint;
  44.      end;
  45.  
  46.  
  47. Procedure ReplaceAtParms(var line : string);
  48. var i : integer;
  49.     s : string;
  50.      begin
  51.     { writeln(line,'<--');}
  52.      for i := 1 to 9 do
  53.           begin
  54.           s := '@'+integerstr(i,1);
  55.           line := FindAndReplaceStr(line,s,AtStr[i],true,true);
  56.           end;
  57.      end;
  58.  
  59.  
  60.  
  61. Procedure PrintLine(line : string);
  62. var s : string;
  63.      begin
  64.      CheckPageLimits(pFirst,pLast,pCount);
  65.      if ord(line[1]) = 12 then
  66.           begin
  67.           writeln('found FF in text currpage = ',OUTCurrentpage);
  68.           OUTdonewithpage;
  69.           exit;
  70.           end;
  71.      if center > 0 then
  72.           begin
  73.           s := centerstr(line,OUTCurrentLineLen);
  74.           dec(center);
  75.           OUT(s);
  76.           end
  77.      else begin
  78.           s := line;
  79.           if TBOXType > 0 then TBOXConvertLine(s);
  80.           OUTjoin(s);
  81.           end;
  82.      if doubleflag then OUT(' ');
  83.      end;
  84.  
  85.  
  86.  
  87. Procedure PrintBlankLines(n : integer);
  88. var i : integer;
  89.      begin
  90.      if (n > 0) and (n < 100) then
  91.          for i := 1 to n do
  92.               begin
  93.               PrintLine(' ');
  94.               end;
  95.      end;
  96.  
  97.  
  98.  
  99. Function CommandLine(var line : string; var newfile,newsect : string) : boolean;
  100. var ret,null    : boolean;
  101.     s,s1,s2,s2u: string;
  102.     termch : char;
  103.     i      : integer;
  104.      begin
  105.      ret := false;
  106.      i := Pos('@',line);
  107.      if i > 0 then ReplaceAtParms(line);
  108.      i := pos(TriggerCh,line);
  109.      if (i = 1) or (i = 2) then
  110.           begin
  111.           if EchoFlag then PrintLine('['+line+']');
  112.           s := line;
  113.           delete(s,1,i);
  114.           if  (i = 2) then delete(s,length(s),1);  {must be in brackets}
  115.           ret := true;
  116.           s1  := UpCaseStr(GetLeftStr(s,' '));
  117.           if length(s1) > 0 then
  118.                begin
  119.                s2  := GetLeftStr(s,' ');
  120.                s2u := UpCaseStr(s2);
  121.                if pDebug then writeln('Command [',s1,']  arg [',s2,']');
  122.                if      s1 = ''          then PrintBlankLines(1)
  123.                else if s1 = 'NEW'       then OUTdonewithpage
  124.                else if s1 = 'INDENT'    then OUTSetIndent(StrInt(s2))
  125.                else if s1 = 'SPACE'     then PrintBlankLines(StrInt(s2))
  126.                else if s1 = 'CENTER'    then
  127.                     begin
  128.                     if      s2u = 'ON'  then center := 9999
  129.                     else if s2u = 'OFF' then center := 0
  130.                     else begin
  131.                          center :=  1;
  132.                          delete(line,1,8);
  133.                          trim(line);
  134.                          line := UnQT(line);
  135.                          ret := false;
  136.                          end;
  137.                     end
  138.                else if s1 = 'HEADERS'    then
  139.                     begin
  140.                     if s2u = '' then s2u := 'ON';
  141.                     if      s2u = 'ON'  then
  142.                          begin
  143.                          headersflag := true;
  144.                          if not footersflag then
  145.                               OUTSetHeaders(pHeader1,pHeader2,pHeader3,'','')
  146.                          else OUTSetHeaders(pHeader1,pHeader2,pHeader3,
  147.                                             pFooter1,pFooter2);
  148.                          end
  149.                     else if s2u = 'OFF' then
  150.                          begin
  151.                          headersflag := false;
  152.                          if not footersflag then
  153.                               OUTSetHeaders('','','','','')
  154.                          else OUTSetHeaders('','','',pFooter1,pFooter2);
  155.                          end;
  156.                     end
  157.                else if s1 = 'FOOTERS'    then
  158.                     begin
  159.                     if s2u = '' then s2u := 'ON';
  160.                     if      s2u = 'ON'  then
  161.                          begin
  162.                          footersflag := true;
  163.                          if not headersflag then
  164.                               OUTSetHeaders('','','',pFooter1,pFooter2)
  165.                          else OUTSetHeaders(pHeader1,pHeader2,pHeader3,
  166.                                             pFooter1,pFooter2);
  167.                          end
  168.                     else if s2u = 'OFF' then
  169.                          begin
  170.                          footersflag := false;
  171.                          if not headersflag then
  172.                               OUTSetHeaders('','','','','')
  173.                          else OUTSetHeaders(pHeader1,pHeader2,pHeader3,'','');
  174.                          end;
  175.                     end
  176.                else if s1 = 'DOUBLESPACE'  then
  177.                     begin
  178.                     if s2u = '' then s2u := 'ON';
  179.                     if      s2u = 'ON'  then doubleflag := true
  180.                     else if s2u = 'OFF' then doubleflag := false;
  181.                     end
  182.                else if s1 = 'JOIN'  then
  183.                     begin
  184.                     if      s2u = 'ON'  then OUTSetJoin
  185.                     else if s2u = 'OFF' then OUTFlushJoin(true)
  186.                     else                     begin
  187.                                              OUTSetJoinWidth(StrInt(s2));
  188.                                              OUTSetJoin;
  189.                                              end;
  190.                     end
  191.                else if s1 = 'ECHO'  then
  192.                     begin
  193.                     if s2u = '' then s2u := 'ON';
  194.                     if      s2u = 'ON'  then EchoFlag := true
  195.                     else if s2u = 'OFF' then EchoFlag := false;
  196.                     end
  197.                else if s1 = 'SOURCE'  then
  198.                     begin
  199.                     newsect := GetDelimitedStr(s2u,'(',')');
  200.                     newfile := s2u;
  201.                    { OUT(' SOURCE ['+newfile+'] ['+newsect+'] ');}
  202.                     end
  203.                else if s1 = 'HEADER1'  then
  204.                     begin
  205.                     s := line; null := ReplaceStringWithToken(s,pHeader1,chr(254));
  206.                     if pDebug then writeln('pHeader1 [',pHeader1,']');
  207.                     OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
  208.                     end
  209.                else if s1 = 'HEADER2'  then
  210.                     begin
  211.                     s := line; null := ReplaceStringWithToken(s,pHeader2,chr(254));
  212.                     OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
  213.                     end
  214.                else if s1 = 'HEADER3'  then
  215.                     begin
  216.                     s := line; null := ReplaceStringWithToken(s,pHeader3,chr(254));
  217.                     OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
  218.                     end
  219.                else if s1 = 'FOOTER1'  then
  220.                     begin
  221.                     s := line; null := ReplaceStringWithToken(s,pFooter1,chr(254));
  222.                     OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
  223.                     end
  224.                else if s1 = 'FOOTER2'  then
  225.                     begin
  226.                     s := line; null := ReplaceStringWithToken(s,pFooter2,chr(254));
  227.                     OUTSetHeaders(pHeader1, pHeader2, pHeader3, pFooter1, pFooter2);
  228.                     end
  229.                else if s1 = 'TBOXTYPE'  then TBOXType := StrInt(s2)
  230.                else if s1 = 'PRINT'     then OUTSetNoPrint
  231.                else if s1 = 'NOPRINT'   then OUTSetPrint
  232.                else if s1 = 'QUIT'      then newfile := s1
  233.                else if s1 = 'EXIT'      then newfile := s1
  234.                else begin ret := false; end;
  235.                end;
  236.           end;
  237.      CommandLine := ret;
  238.      end;
  239.  
  240.  
  241. Procedure ProcessSourcedLine(line : string);
  242. var newfile,newsect : string;
  243.      begin
  244.      if SectLineFlag then
  245.           begin  { skip this line for printing purposes }
  246.           SectLineFlag := false;
  247.           exit;
  248.           end;
  249.      newfile := '';
  250.      newsect := '';
  251.      if not CommandLine(line,newfile,newsect) then
  252.           begin
  253.           PrintLine(line);
  254.           end;
  255.      if newfile <> '' then PrintLine('Nesting too deep - '+newfile);
  256.      end;
  257.  
  258.  
  259.  
  260. Procedure ReadFile1(fname : string);
  261. var i,linenumber : integer;
  262.     line       : string;
  263.     newfile    : string[40];
  264.     newsect    : string[40];
  265.     done       : boolean;
  266.     tx         : TFILE_object;
  267.      begin
  268.      pCurrFName := fname;
  269.      OUTSetPageLabels(PackTimeStr(FileDate(pCurrFname,'')),'','');
  270.      linenumber := 0;
  271.      newfile    := '';  newsect := '';
  272.      done := false;
  273.      if not fileexists(fname) then
  274.           begin
  275.           forceext(fname,'txt');
  276.           if not fileexists(fname) then
  277.                begin
  278.                forceext(fname,'doc');
  279.                if not fileexists(fname) then
  280.                     begin
  281.                     writeln('No file found [',pCurrFName,']');
  282.                     exit;
  283.                     end;
  284.                end;
  285.           end;
  286.      tx.init(fname,false);
  287.      while tx.fetchnext(line) and not done do
  288.          begin
  289.          pCurrFName := fname;
  290.          OUTSetPageLabels(PackTimeStr(FileDate(pCurrFname,'')),'','');
  291.          inc(linenumber);
  292.          if not CommandLine(line,newfile,newsect) then
  293.               begin
  294.               pCurrFName := fname;
  295.               PrintLine(line);
  296.               end;
  297.          if (newfile = 'EXIT') or (newfile = 'QUIT') then done := true
  298.          else if SourceFlag and (newfile <> '') then
  299.               begin
  300.               if newsect <> '' then
  301.                    begin
  302.                   { OUT(' sourcing ['+newfile+'] ['+secttag+'] ['+newsect+'] ');}
  303.                    SectLineFlag := true;
  304.                                   ReadTEXTSection(newfile,secttag,newsect,0,ProcessSourcedLine);
  305.                    end
  306.               else ReadTEXTfile(newfile,ProcessSourcedLine);
  307.               end;
  308.          newfile := '';
  309.          newsect := '';
  310.          end;
  311.      tx.done;
  312.      end;
  313.  
  314.  
  315. Procedure AddDollarParms;
  316. var i : integer;
  317.     s : string;
  318.      begin
  319.      for i := 1 to 9 do
  320.           begin
  321.           s := '@'+integerstr(i,1);
  322.           AddParm(1,s,'');
  323.           end;
  324.      end;
  325.  
  326.  
  327. Procedure GetDollarParms;
  328. var i : integer;
  329.     s : string;
  330.      begin
  331.      for i := 1 to 9 do
  332.           begin
  333.           s := '@'+integerstr(i,1);
  334.           AtStr[i] := GetParmStr(s);
  335.           end;
  336.      end;
  337.  
  338.  
  339. Procedure DumpDollarParms;
  340. var i : integer;
  341.      begin
  342.      writeln('Dollar Parms');
  343.      for i := 1 to 9 do
  344.          if AtStr[i] <> '' then writeln('  @',i:1,' = [',AtStr[i],']');
  345.      writeln('');
  346.      end;
  347.  
  348.  
  349. Procedure Init;
  350.      begin
  351.      SectLineFlag := false;
  352.      AddParm(1,'SOURCE','YES');
  353.      AddParm(1,'ECHO','NO');
  354.      AddParm(1,'COMPRESSED','NO');
  355.      AddParm(1,'TRIGGER','92');              { \ }
  356.      AddParm(1,'SECTTAG','{SECTION');
  357.      AddParm(1,'TBOXTYPE','1');
  358.      AddParm(1,'HEADERS','YES');
  359.      AddParm(1,'FOOTERS','YES');
  360.      AddParm(1,'HEADER1','');
  361.      AddParm(1,'HEADER2','');
  362.      AddParm(1,'HEADER3','');
  363.      AddParm(1,'FOOTER1','||@PAGE');
  364.      AddParm(1,'FOOTER2','');
  365.      center      := 0;
  366.      doubleflag  := false;
  367.  
  368.      AddDollarParms;
  369.      StandardOUTInit;
  370.      PARMSetFirstLast;
  371.      GetDollarParms;
  372.  
  373.      SourceFlag  := CheckOK('SOURCE');
  374.      TriggerCh   := chr(GetParmNum('TRIGGER'));
  375.      EchoFlag    := CheckOK('ECHO');
  376.      DoubleFlag  := CheckOK('DOUBLE');
  377.      HeadersFlag := CheckOK('HEADERS');
  378.      FootersFlag := CheckOK('FOOTERS');
  379.      TBOXType    := GetParmNum('TBOXTYPE');
  380.      secttag     := GetParmStr('SECTTAG');
  381.  
  382.      quotechar    := '''';  { Single quote - for scan stuff }
  383.  
  384.      OUTSetHeaders(pHeader1,pHeader2,pHeader3,pFooter1,pFooter2);
  385.      end;
  386.  
  387.  
  388.      begin
  389.      pProgID := 'TPrint 3.02';
  390.      Init;
  391.      if pDebug then DumpDollarParms;
  392.      if paramcount > 0 then
  393.           begin
  394.           ReadFile1(paramstr(1));
  395.           OUTdone;
  396.           end
  397.      else ShowDocFile;
  398.      end.
  399.